Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue52/HTML/Code/AppServer/usXMLDoc.pas

Pascal/Delphi Source File | 1999-10-23 | 10.7 KB | 430 lines

unit usXMLDoc;

interface

uses
  Classes, XmlParser {CueSoft};

type
  TusXMLDocument = class;

  { TusXMLAttribute - a single tag attribute }
  TusXMLAttribute = class(TPersistent)
  private
    FName: string;
    FValue: string;
  public
    procedure Assign(aSource: TPersistent); override;
    property Name: string read FName write FName;
    property Value: string read FValue write FValue;
  end;

  { TusXMLAttributes - a list of all attributes for a tag }
  TusXMLAttributes = class(TPersistent)
  protected
    FList: TList;
    function GetCount: Integer;
    function GetItem(aIndex: Integer): TusXMLAttribute;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(aItem: TusXMLAttribute);
    procedure Assign(aSource: TPersistent); override;
    procedure Clear;
    function GetByName(aName: string): TusXMLAttribute;
    function Value(aName: string): string;
    property Count: Integer read GetCount;
    property Items[aIndex: Integer]: TusXMLAttribute read GetItem; default;
  end;

  { TusXMLElement - a single element (tag) }
  TusXMLElement = class
  private
    FAttributes: TusXMLAttributes;
    FData: string;
    FLevel: SmallInt;
    FParent: TusXMLElement;
    FSubtags: TusXMLDocument;
    FTagName: string;
  public
    constructor Create;
    destructor Destroy; override;
    property Attributes: TusXMLAttributes read FAttributes;
    property Data: string read FData write FData;
    property Level: SmallInt read FLevel write FLevel;
    property Parent: TusXMLElement read FParent;
    property Subtags: TusXMLDocument read FSubtags;
    property TagName: string read FTagName write FTagName;
  end;

  { TusXMLDocument - a contiguous block of XML tags }
  TusXMLDocument = class
  private
  protected
    FList: TList;
    FRoot: TusXMLElement;
    procedure AddElement(aElement: TusXMLElement);
    function CreateNode(aParent: TusXMLElement; aTagName,
      aData: string): TusXMLElement;
    function GetCount: Integer;
    function GetItem(aIndex: Integer): TusXMLElement;
  public
    constructor Create;
    destructor Destroy; override;
    function Add(aSibling: TusXMLElement; aName, aValue: string): TusXMLElement;
    function AddChild(aParent: TusXMLElement; aName, aValue: string): TusXMLElement;
    procedure Clear;
    function GetFirstElement(aTagName: string): TusXMLElement;
    property Count: Integer read GetCount;
    property Items[aIndex: Integer]: TusXMLElement read GetItem; default;
    property Root: TusXMLElement read FRoot;
  end;

  { TusParser - parses raw XML and yields a TusXMLDocument structure }
  TusXMLParser = class
  private
    FDocument: TusXMLDocument;

    { The following private declarations are specific to the third-party
      parser being used to implement this class. }
    Parser: TXMLParser;
    NestingLevel: Integer;
    LastElement: TusXMLElement;
    Attributes: TusXMLAttributes;
  protected
    procedure DoOnAttribute(aSender: TObject; aName, aValue: string; aSpecified: Boolean);
    procedure DoOnCDATASection(aSender: TObject; aValue: string);
    procedure DoOnCharData(aSender: TObject; aValue: string);
    procedure DoOnEndElement(aSender: TObject; aValue: string);
    procedure DoOnStartDocument(aSender: TObject);
    procedure DoOnStartElement(aSender: TObject; aValue: string);
  public
    constructor Create;
    destructor Destroy; override;
    procedure LoadXML(aXML: string); virtual;
    property Document: TusXMLDocument read FDocument;
  end;

implementation

uses
  SysUtils;

{ TusXMLAttribute }

procedure TusXMLAttribute.Assign(aSource: TPersistent);
begin
  if aSource is TusXMLAttribute then
  begin
    FName := TusXMLAttribute(aSource).FName;
    FValue := TusXMLAttribute(aSource).FValue;
  end
  else
    inherited Assign(aSource);
end;

{ TusXMLAttributes }

procedure TusXMLAttributes.Add(aItem: TusXMLAttribute);
begin
  FList.Add(aItem);
end;

procedure TusXMLAttributes.Assign(aSource: TPersistent);
var
  I: Integer;
begin
  if aSource is TusXMLAttributes then
  begin
    Clear;
    for I := 0 to TusXMLAttributes(aSource).Count - 1 do
    begin
      Add(TusXMLAttribute.Create);
      Items[Count - 1].Assign(TusXMLAttributes(aSource)[I]);
    end;
  end
  else
    inherited Assign(aSource);
end;

procedure TusXMLAttributes.Clear;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    Items[I].Free;
  FList.Clear;
end;

constructor TusXMLAttributes.Create;
begin
  inherited;
  FList := TList.Create;
end;

destructor TusXMLAttributes.Destroy;
begin
  Clear;
  FList.Free;
  inherited;
end;

function TusXMLAttributes.GetByName(aName: string): TusXMLAttribute;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to Count - 1 do
    if CompareText(aName, Items[I].Name) = 0 then
    begin
      Result := Items[I];
      Break;
    end;
end;

function TusXMLAttributes.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TusXMLAttributes.GetItem(aIndex: Integer): TusXMLAttribute;
begin
  Result := TusXMLAttribute(FList[aIndex]);
end;

function TusXMLAttributes.Value(aName: string): string;
var
  Attr: TusXMLAttribute;
begin
  Result := '';
  Attr := GetByName(aName);
  if Assigned(Attr) then
    Result := Attr.Value;
end;

{ TusXMLElement }

constructor TusXMLElement.Create;
begin
  inherited;
  FAttributes := TusXMLAttributes.Create;
  FSubtags := TusXMLDocument.Create;
end;

destructor TusXMLElement.Destroy;
begin
  FAttributes.Free;
  FSubtags.Free;
  inherited;
end;

{ TusXMLDocument }

function TusXMLDocument.Add(aSibling: TusXMLElement; aName,
  aValue: string): TusXMLElement;
{ Add a new XML element to the list }
begin
  if not Assigned(aSibling) then
  begin
    Result := CreateNode(nil, aName, aValue);
    AddElement(Result);
  end
  else
  begin
    Result := CreateNode(aSibling.Parent, aName, aValue);
    Result.Level := aSibling.Parent.Level + 1;
    aSibling.Parent.Subtags.AddElement(Result);
  end;
end;

function TusXMLDocument.AddChild(aParent: TusXMLElement; aName,
  aValue: string): TusXMLElement;
begin
  Assert(Assigned(aParent), 'Parent element not assigned.');

  Result := CreateNode(aParent, aName, aValue);
  Result.Level := aParent.Level + 1;
  aParent.Subtags.AddElement(Result);
end;

procedure TusXMLDocument.AddElement(aElement: TusXMLElement);
begin
  FList.Add(aElement);
  if not Assigned(FRoot) then
    FRoot := aElement;
end;

procedure TusXMLDocument.Clear;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    TusXMLElement(FList[I]).Free;
  FList.Clear;
  FRoot := nil;
  inherited;
end;

constructor TusXMLDocument.Create;
begin
  inherited;
  FList := TList.Create;
end;

function TusXMLDocument.CreateNode(aParent: TusXMLElement; aTagName, aData: string): TusXMLElement;
{ If aParent is unassigned, then we are added a zero-level node }
begin
  Result := TusXMLElement.Create;
  Result.TagName := AnsiUpperCase(aTagName);
  Result.Data := aData;
  Result.FParent := aParent;
end;

destructor TusXMLDocument.Destroy;
begin
  Clear;
  FList.Free;
  inherited;
end;

function TusXMLDocument.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TusXMLDocument.GetFirstElement(aTagName: string): TusXMLElement;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to Root.Subtags.Count - 1 do
    if CompareText(aTagName, Root.Subtags[I].TagName) = 0 then
    begin
      Result := Items[I];
      Exit;
    end;
end;

function TusXMLDocument.GetItem(aIndex: Integer): TusXMLElement;
begin
  Result := TusXMLElement(FList[aIndex]);
end;

{ TusXMLParser }

constructor TusXMLParser.Create;
begin
  inherited;
  Parser := TXMLParser.Create(nil);
  with Parser do
  begin
    NormalizeData := True;
    OnStartDocument := DoOnStartDocument;
    OnAttribute := DoOnAttribute;
    OnStartElement := DoOnStartElement;
    OnCDATASection := DoOnCDATASection;
    OnCharData := DoOnCharData;
    OnEndElement := DoOnEndElement;
  end;
  Attributes := TusXMLAttributes.Create;
  FDocument := TusXMLDocument.Create;
end;

destructor TusXMLParser.Destroy;
begin
  Attributes.Free;
  FDocument.Free;
  Parser.Free;
  inherited;
end;

procedure TusXMLParser.DoOnAttribute(aSender: TObject; aName,
  aValue: string; aSpecified: Boolean);
{ OnAttribute is fired BEFORE the OnStartElement for the tag containing
  the attributes.  So we must accumulate the attributes and wait for the
  OnStartElement event. }
var
  A: TusXMLAttribute;
begin
  A := TusXMLAttribute.Create;
  A.Name := ANSILowercase(aName);
  A.Value := aValue;
  Attributes.Add(A);
end;

procedure TusXMLParser.DoOnCDATASection(aSender: TObject; aValue: string);
begin
  with LastElement do
  begin
    Data := Data + aValue;
  end;
end;

procedure TusXMLParser.DoOnCharData(aSender: TObject; aValue: string);
begin
  with LastElement do
  begin
    Data := Data + aValue;
  end;
end;

procedure TusXMLParser.DoOnEndElement(aSender: TObject; aValue: string);
begin
  Dec(NestingLevel);
end;

procedure TusXMLParser.DoOnStartDocument(aSender: TObject);
begin
  LastElement := nil;
  NestingLevel := -1;
  Attributes.Clear;
end;

procedure TusXMLParser.DoOnStartElement(aSender: TObject; aValue: string);
{ On entry: LastElement refers to the last element we created or nil if
  this is the first element.
  We create a new element and LastElement now points to the new element. }
var
  ParentElement: TusXMLElement;
  I: Integer;
begin
  Inc(NestingLevel);
  if not Assigned(LastElement) or (NestingLevel = LastElement.Level) then
    { root element (XML tag), or new sibling of previous element }
    LastElement := FDocument.Add(LastElement, aValue, '')
  else
    if NestingLevel > LastElement.Level then
      { first child of previous element }
      LastElement := FDocument.AddChild(LastElement, aValue, '')
    else
    begin
      { next sibling of previous element's parent }
      ParentElement := LastElement;
      for I := LastElement.Level - 1 downto NestingLevel do
        ParentElement := ParentElement.Parent;
      LastElement := FDocument.Add(ParentElement, aValue, '');
    end;

  { Copy attributes }
  LastElement.Attributes.Assign(Attributes);
  Attributes.Clear;
end;

procedure TusXMLParser.LoadXML(aXML: string);
var
  ErrorMsg: string;
  I: Integer;
begin
  Document.Clear;
  if not Parser.ParseMemory(PChar(aXML)) then
    with Parser.Errors do
    begin
      ErrorMsg := 'Error parsing UWML:';
      for I := 0 to Count - 1 do
        ErrorMsg := ErrorMsg + #13#10 + Strings[I];
      raise Exception.Create(ErrorMsg);
    end;
end;

end.